Fuente:https://rpubs.com/profe_ferro/1362995
library(tidyverse)
library(dplyr)
library(ggplot2)
library(ggrepel)
library(plotly)
library(ggridges)
library(rpart)
library(rpart.plot)
library(scales)
Simulamos frecuencia y severidad por asegurado y año con variables típicas para segmentación.
set.seed(2025)
n <- 2500
df <- tibble(
anio = sample(2021:2024, n, replace = TRUE, prob = c(0.2, 0.3, 0.3, 0.2)),
region = sample(c("Andina","Caribe","Pacífico","Orinoquía"), n,
replace = TRUE, prob = c(0.5,0.2,0.25,0.05)),
tipo_vehiculo = sample(c("Sedán","SUV","Moto","Pickup"), n,
replace = TRUE, prob = c(0.4,0.3,0.2,0.1)),
edad = pmin(pmax(round(rnorm(n, 42, 12)), 18), 80),
genero = sample(c("F","M"), n, replace = TRUE, prob = c(0.45, 0.55)),
# Exposición anual (años asegurado): entre 0.2 y 1
expo = round(runif(n, 0.2, 1.0), 2)
) |>
mutate(
# Frecuencia (Poisson) condicionada por segmentos
lambda_base = 0.25 +
0.05*(tipo_vehiculo=="Moto") +
0.07*(tipo_vehiculo=="Pickup") +
0.03*(region=="Caribe") +
0.04*(edad < 25) +
0.02*(edad > 70),
reclamos = rpois(n, lambda = pmax(lambda_base * expo, 0.01)),
# Severidad lognormal dependiente del tipo de vehículo
mu_sev = 8.0 + 0.25*(tipo_vehiculo %in% c("SUV","Pickup")),
sigma_sev = 0.6 + 0.05*(region=="Pacífico"),
costo_prom = rlnorm(n, meanlog = mu_sev, sdlog = sigma_sev),
# Costo total (severidad por número de reclamos)
costo_total = round(costo_prom * pmax(reclamos, 1) * rlnorm(n, 0, 0.2), 0),
prima = round( # prima simple basada en frecuencia esperada y severidad típica
(lambda_base * exp(mu_sev + (sigma_sev^2)/2)) * 1.15 * expo, 0
)
) |>
mutate(
# Tasa de siniestralidad (loss ratio) simple
loss_ratio = costo_total / pmax(prima, 1)
)
glimpse(df)
## Rows: 2,500
## Columns: 14
## $ anio <int> 2024, 2023, 2023, 2023, 2024, 2023, 2021, 2022, 2024, 20…
## $ region <chr> "Pacífico", "Pacífico", "Andina", "Pacífico", "Andina", …
## $ tipo_vehiculo <chr> "SUV", "SUV", "Moto", "Moto", "Sedán", "Sedán", "Moto", …
## $ edad <dbl> 55, 50, 45, 41, 53, 44, 63, 38, 36, 40, 61, 35, 45, 38, …
## $ genero <chr> "F", "M", "M", "F", "M", "F", "M", "M", "M", "M", "M", "…
## $ expo <dbl> 0.52, 0.22, 0.95, 0.46, 0.89, 0.87, 0.44, 0.53, 0.26, 0.…
## $ lambda_base <dbl> 0.25, 0.25, 0.30, 0.30, 0.25, 0.25, 0.30, 0.25, 0.33, 0.…
## $ reclamos <int> 0, 1, 0, 0, 1, 0, 0, 0, 0, 0, 1, 0, 1, 0, 1, 0, 0, 0, 0,…
## $ mu_sev <dbl> 8.25, 8.25, 8.00, 8.00, 8.00, 8.00, 8.00, 8.00, 8.00, 8.…
## $ sigma_sev <dbl> 0.65, 0.65, 0.60, 0.65, 0.60, 0.65, 0.60, 0.60, 0.60, 0.…
## $ costo_prom <dbl> 2033.355, 4577.208, 1606.826, 7117.637, 3959.740, 5172.4…
## $ costo_total <dbl> 1865, 5315, 1579, 7732, 3837, 3745, 2690, 2614, 3993, 11…
## $ prima <dbl> 707, 299, 1170, 584, 913, 921, 542, 544, 352, 1080, 1156…
## $ loss_ratio <dbl> 2.6379066, 17.7759197, 1.3495726, 13.2397260, 4.2026287,…
df |>
ggplot(aes(costo_total)) +
geom_histogram(bins = 40, color = "white") +
scale_x_log10(labels = label_number(scale_cut = cut_si(" "))) +
labs(title = "Distribución de costos (log10)",
x = "Costo total (log10)",
y = "Frecuencia")
Interpretación: Se ve una distribución altamente asimétrica con mayoría de costos bajos y una cola larga de pocos siniestros de alto costo.
df |>
ggplot(aes(costo_total, fill = tipo_vehiculo)) +
geom_density(alpha = 0.3) +
scale_x_log10(labels = scales::label_number(scale_cut = scales::cut_si(" "))) +
labs(title = "Densidad de costos por tipo de vehículo",
x = "Costo total (log10)", y = "Densidad")
Interpretación: Las motos muestran una distribución de costos más concentrada en valores bajos, mientras que SUV y Pickup presentan colas más pesadas hacia costos altos, indicando mayor severidad.
df |>
ggplot(aes(tipo_vehiculo, costo_total, fill = tipo_vehiculo)) +
geom_boxplot(outlier.alpha = 0.2) +
scale_y_log10(labels = scales::label_number(scale_cut = scales::cut_si(" "))) +
labs(title = "Severidad por tipo de vehículo",
y = "Costo total (log10)", x = NULL)
Interpretación: Los vehículos SUV y Pickup presentan mayor severidad promedio y variabilidad en costos, mientras las motos muestran costos más bajos y consistentes.
set.seed(1)
df |>
sample_n(800) |>
ggplot(aes(tipo_vehiculo, costo_total, fill = tipo_vehiculo)) +
geom_violin(trim = FALSE, alpha = 0.2) +
geom_jitter(width = 0.1, alpha = 0.25) +
scale_y_log10(labels = scales::label_number(scale_cut = scales::cut_si(" "))) +
labs(title = "Distribución intra-segmento (violín + puntos)",
y = "Costo total (log10)")
Interpretación: Se ve una mayor densidad de costos bajos en motos y dispersión en SUV y Pickup, mostrando asimetría y valores atípicos en estos últimos segmentos.
df |>
ggplot(aes(costo_total, region)) +
geom_density_ridges(rel_min_height = 0.01, scale = 1.2) +
scale_x_log10(labels = scales::label_number(scale_cut = scales::cut_si(" "))) +
labs(title = "Perfiles de severidad por región (ridgelines)",
x = "Costo total (log10)", y = NULL)
## Picking joint bandwidth of 0.0752
Interpretación: La región Pacífico muestra una distribución de costos más extendida hacia valores altos, sugiriendo mayor severidad comparada con otras regiones.
df |>
ggplot(aes(edad, costo_total, color = tipo_vehiculo)) +
geom_point(alpha = 0.35) +
geom_smooth(se = FALSE, method = "loess") +
scale_y_log10(labels = scales::label_number(scale_cut = scales::cut_si(" "))) +
labs(title = "Edad vs Costo total (con suavizado)",
x = "Edad", y = "Costo total (log10)")
## `geom_smooth()` using formula = 'y ~ x'
Interpretación: Se observa mayor costo en conductores jóvenes (menores de 25 años) y un incremento gradual después de los 70 años, siendo más pronunciado en Moto.
df |>
ggplot(aes(edad, costo_total, size = expo, color = region)) +
geom_point(alpha = 0.4) +
scale_y_log10(labels = scales::label_number(scale_cut = scales::cut_si(" "))) +
labs(title = "Burbuja: edad vs costo (tamaño = exposición)",
x = "Edad", y = "Costo total (log10)", size = "Exposición")
Interpretación: La gráfica es está muy saturada, por lo que es difícil inferir alguna conclusión sobre esta.
df |>
group_by(tipo_vehiculo) |>
summarise(mean_rec = mean(reclamos), se = sd(reclamos)/sqrt(n())) |>
ggplot(aes(fct_reorder(tipo_vehiculo, mean_rec), mean_rec)) +
geom_col() +
geom_errorbar(aes(ymin = mean_rec - 1.96*se, ymax = mean_rec + 1.96*se), width = 0.2) +
coord_flip() +
labs(title = "Frecuencia media de reclamos por tipo",
x = NULL, y = "Reclamos por año (promedio)")
Interpretación: Las motos y pickups presentan la mayor frecuencia de reclamos, consistentes con los parámetros simulados de mayor lambda_base para estos tipos.
df |>
group_by(anio) |>
summarise(mediana = median(costo_total)) |>
ggplot(aes(anio, mediana)) +
geom_line() +
geom_point() +
scale_y_log10(labels = scales::label_number(scale_cut = scales::cut_si(" "))) +
labs(title = "Evolución de severidad (mediana)",
x = "Año", y = "Costo mediano (log10)")
Interpretación: La severidad mediana muestra una tendencia creciente sostenida a lo largo de los años tras una caida en 2022, indicando inflación de costos de siniestros en el periodo.
df_hm <- df |>
mutate(edad_grupo = cut(edad, breaks = c(18,25,35,45,55,65,80),
labels = c("18-25","26-35","36-45","46-55","56-65","66-80"),
include.lowest = TRUE)) |>
group_by(edad_grupo, tipo_vehiculo) |>
summarise(mediana = median(costo_total), .groups = "drop")
df_hm |>
ggplot(aes(tipo_vehiculo, edad_grupo, fill = mediana)) +
geom_tile(color = "white") +
scale_fill_viridis_c(labels = scales::label_number(scale_cut = scales::cut_si(" "))) +
labs(title = "Heatmap de severidad mediana",
x = "Tipo de vehículo", y = "Grupo de edad", fill = "Mediana")
Interpretación: Los SUV y Pickup muestran mayor severidad en todos los grupos etarios, mientras las motos mantienen costos consistentemente más bajos independientemente de la edad. El grupo de jóvenes en Pickup es el que mayor severidad tiene con diferencia al resto.
df |>
group_by(region, tipo_vehiculo) |>
summarise(lr = mean(loss_ratio), .groups = "drop") |>
ggplot(aes(tipo_vehiculo, region, fill = lr)) +
geom_tile(color = "white") +
scale_fill_viridis_c() +
labs(title = "Mapa de calor de loss ratio promedio",
x = "Tipo de vehículo", y = "Región", fill = "LR")
Interpretación: Las motos en la región Orinoquía muestran el loss ratio más elevado, indicando sub-preciación significativa en este segmento específico.
num_vars <- df |>
transmute(edad, expo, reclamos, costo_total = log10(costo_total + 1), prima = log10(prima + 1), loss_ratio)
corr <- cor(num_vars, use = "pairwise.complete.obs")
tibble(
var1 = rep(rownames(corr), times = ncol(corr)),
var2 = rep(colnames(corr), each = nrow(corr)),
r = as.vector(corr)
) |>
ggplot(aes(var1, var2, fill = r)) +
geom_tile(color = "white") +
scale_fill_gradient2(limits = c(-1,1)) +
coord_equal() +
labs(title = "Mapa de calor de correlaciones", x = NULL, y = NULL, fill = "r")
Interpretación: Fuerte correlación positiva entre costo_total y reclamos, mientras loss_ratio muestra relación inversa con prima, sugiriendo posibles desajustes tarifarios.
df |>
arrange(desc(costo_total)) |>
mutate(pct = costo_total / sum(costo_total),
acum = cumsum(pct),
idx = row_number()) |>
ggplot(aes(idx, acum)) +
geom_line() +
geom_hline(yintercept = 0.8, linetype = "dashed") +
labs(title = "Curva de Pareto: contribución acumulada del costo",
x = "Pólizas ordenadas por costo", y = "Acumulado")
Interpretación: El 20% de las pólizas más costosas concentran aproximadamente el 80% del costo total, confirmando el principio de Pareto en la siniestralidad.
p80 <- quantile(df$costo_total, 0.80)
df_tree <- df |>
mutate(alto_costo = if_else(costo_total > p80, "SI","NO")) |>
select(alto_costo, edad, region, tipo_vehiculo, expo, reclamos, prima)
set.seed(99)
fit <- rpart(alto_costo ~ ., data = df_tree, method = "class",
control = rpart.control(cp = 0.01, minbucket = 100))
rpart.plot(fit, type = 2, extra = 104, box.palette = "RdYlGn", branch.lty = 2, shadow.col = "gray")
Interpretación:
p1 <- df |>
ggplot(aes(edad, costo_total, color = tipo_vehiculo)) +
geom_point(alpha = 0.5) +
scale_y_log10(labels = scales::label_number(scale_cut = scales::cut_si(" "))) +
labs(title = "Interactivo: Edad vs Costo por tipo de vehículo",
x = "Edad", y = "Costo total (log10)")
ggplotly(p1)
Interpretación:
p2 <- df |>
group_by(region, tipo_vehiculo) |>
summarise(lr = mean(loss_ratio), .groups = "drop") |>
ggplot(aes(tipo_vehiculo, region, fill = lr)) +
geom_tile(color = "white") +
labs(title = "Interactivo: Loss ratio promedio",
x = "Tipo de vehículo", y = "Región", fill = "LR")
ggplotly(p2)
Interpretación:
Gráfico: Severidad (costo_total) por tipo_vehiculo facetado por anio.
df |>
ggplot(aes(tipo_vehiculo, costo_total, fill = tipo_vehiculo)) +
geom_boxplot(outlier.alpha = 0.2) +
scale_y_log10(labels = label_number(scale_cut = cut_si(" "))) +
facet_wrap(~ anio) +
labs(title = "Severidad por tipo de vehículo y año", x = NULL, y = "Costo (log10)")
Preguntas a responder:
SUV y Pickup muestran los costos más altos en todos los años.
No se observan cambios significativos en el ranking de severidad entre segmentos a través del tiempo. Esto es relevante porque indica estabilidad en los patrones de costos, permitiendo mantener la estructura de primas sin reordenamientos mayores.
SUV y Pickup serían candidatos a aumentos de prima, mientras que las Motos podrían mantener o reducir tarifas dado su consistente menor severidad.
Gráfico: Severidad mediana por tipo_vehiculo × grupo de edad.
df_hm <- df |>
mutate(edad_grupo = cut(edad, breaks = c(18,25,35,45,55,65,80),
labels = c("18-25","26-35","36-45","46-55","56-65","66-80"),
include.lowest = TRUE)) |>
group_by(edad_grupo, tipo_vehiculo) |>
summarise(mediana = median(costo_total), .groups = "drop")
df_hm |>
ggplot(aes(tipo_vehiculo, edad_grupo, fill = mediana)) +
geom_tile(color = "white") +
scale_fill_viridis_c(labels = label_number(scale_cut = cut_si(" "))) +
labs(title = "Mapa de severidad mediana", x = "Tipo de vehículo", y = "Grupo de edad")
Preguntas a responder:
Conductores jóvenes (18-25 años) con Pickup muestran la mayor severidad mediana.
Aplicaría a SUV y Pickup en el grupo de 18-25 años, por presentar los costos más elevados.
os sedanes y motos en todos los grupos de edad (especialmente conductores maduros de 36-55 años) están subsidiando a los SUV y pickups de conductores jóvenes, al tener menor severidad pero probablemente primas no diferenciadas suficiente.
Gráfico: ¿Cuántas pólizas explican el 80% del costo total?
df |>
arrange(desc(costo_total)) |>
mutate(acum = cumsum(costo_total) / sum(costo_total),
idx = row_number()) |>
ggplot(aes(idx, acum)) +
geom_line(color="steelblue") +
geom_hline(yintercept = 0.8, linetype = "dashed") +
labs(title = "Curva de Pareto del costo", x = "Pólizas ordenadas", y = "Acumulado")
Preguntas a responder:
Aproximadamente 500 pólizas (20% del total) concentran el 80% del costo total.
Confirma alta concentración del riesgo donde pocos siniestros grandes impactan significativamente los resultados, característico de distribuciones con cola pesada.
Sí, completamente. Sería más adecuado un stop-loss por evento o agregado para proteger contra siniestros individuales catastróficos, más que un quota share que cede toda la cartera uniformemente.